home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / record.scm < prev    next >
Text File  |  1995-10-13  |  3KB  |  120 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; This is file record.scm.
  4.  
  5. ;;;; Records
  6.  
  7. ; Every record in the image is assumed to be made either by
  8. ; make-record-type or by a procedure returned by record-constructor.
  9.  
  10. (define (record-type r)
  11.   (record-ref r 0))
  12.  
  13. (define *record-type-uid* -1)
  14. (define *record-type* #f)
  15.  
  16. (define (make-record-type name field-names)
  17.   (set! *record-type-uid* (+ *record-type-uid* 1))
  18.   (let ((r (make-record 5 (unspecific))))
  19.     (record-set! r 0 *record-type*)
  20.     (record-set! r 1 *record-type-uid*)
  21.     (record-set! r 2 name)
  22.     (record-set! r 3 field-names)
  23.     (record-set! r 4 default-record-discloser)
  24.     r))
  25.  
  26. (define (record-type? obj)
  27.   (and (record? obj)
  28.        (eq? (record-type obj) *record-type*)))
  29.  
  30. (define (record-type-uid rt)         (record-ref rt 1))
  31. (define (record-type-name rt)        (record-ref rt 2))
  32. (define (record-type-field-names rt) (record-ref rt 3))
  33. (define (record-type-discloser rt)   (record-ref rt 4))
  34.  
  35. (define (record-field-index rt name)
  36.   (let loop ((names (record-type-field-names rt))
  37.          (i 1))
  38.     (cond ((null? names) (error "unknown field"
  39.                 (record-type-name rt)
  40.                 name))
  41.       ((eq? name (car names))
  42.        i)
  43.       (else (loop (cdr names) (+ i 1))))))
  44.  
  45. (define (record-constructor rt names)
  46.   (let ((indexes (map (lambda (name)
  47.             (record-field-index rt name))
  48.               names))
  49.     (size (+ 1 (length (record-type-field-names rt)))))
  50.     (lambda args
  51.       (let ((r (make-record size (unspecific))))
  52.     (record-set! r 0 rt)
  53.     (let loop ((is indexes) (as args))
  54.       (if (null? as)
  55.           (if (null? is)
  56.           r
  57.           (error "too few arguments to record constructor"
  58.              rt names args))
  59.           (if (null? is)
  60.           (error "too many arguments to record constructor"
  61.              rt names args)
  62.           (begin (record-set! r (car is) (car as))
  63.              (loop (cdr is) (cdr as))))))))))
  64.  
  65. (define (record-accessor rt name)
  66.   (let ((index (record-field-index rt name))
  67.     (error-cruft `(record-accessor ,rt ',name)))
  68.     (lambda (r)
  69.       (if (eq? (record-type r) rt)
  70.       (record-ref r index)
  71.       (call-error "invalid record access" error-cruft r)))))
  72.  
  73. (define (record-modifier rt name)
  74.   (let ((index (record-field-index rt name))
  75.     (error-cruft `(record-modifier ,rt ',name)))
  76.     (lambda (r x)
  77.       (if (eq? (record-type r) rt)
  78.       (record-set! r index x)
  79.       (call-error "invalid record modification" error-cruft r x)))))
  80.  
  81. (define (record-predicate rt)
  82.   (lambda (x)
  83.     (and (record? x)
  84.      (eq? (record-type x) rt))))
  85.  
  86. ; disclose-record calls the record's discloser procedure to obtain a list
  87. ; whose head is a string and whose tail is other stuff.
  88.  
  89. (define (define-record-discloser rt proc)
  90.   (if (and (record-type? rt)
  91.        (procedure? proc))
  92.       (record-set! rt 4 proc)
  93.       (call-error "invalid argument" define-record-discloser rt proc)))
  94.  
  95. (define (disclose-record r)
  96.   (if (record? r)
  97.       (let ((rt (record-type r)))
  98.     (if (record-type? rt)
  99.         (or ((record-type-discloser rt) r)
  100.         (list (record-type-name rt)))
  101.         #f))            ;Not one of ours.
  102.       #f))
  103.  
  104. (define default-record-discloser
  105.   (lambda (r) #f))
  106.  
  107. ; Patch
  108.  
  109. (set! *record-type*
  110.       (make-record-type 'record-type '(uid name field-names discloser)))
  111. (record-set! *record-type* 0 *record-type*)
  112.  
  113. (define :record-type *record-type*)
  114.  
  115. (define-record-discloser :record-type
  116.   (lambda (rt)
  117.     (list 'record-type
  118.       (record-type-uid rt)
  119.       (record-type-name rt))))
  120.